home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 4 / adb / s-debpoo < prev    next >
Text File  |  1996-02-12  |  7KB  |  197 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                  S Y S T E M . D E B U G _ P O O L S                     --
  6. --                                                                          --
  7. --                                B o d y                                   --
  8. --                                                                          --
  9. --                            $Revision: 1.2 $                              --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Unchecked_Conversion;
  37. with Gnat.Htable;
  38. package body System.Debug_Pools is
  39.  
  40.    use System.Storage_Elements;
  41.  
  42.    Accessing_Not_Allocated_Storage : exception;
  43.    Accessing_Reallocated_Storage   : exception;
  44.    Accessing_Deallocated_Storage   : exception;
  45.    Freeing_Not_Allocated_Storage   : exception;
  46.  
  47.    --  Definition of a H-table storing the status of each storage chunck
  48.    --  used by this pool
  49.  
  50.    type State is (Not_Allocated, Deallocated, Allocated);
  51.    type Status is record
  52.       Stat : State;
  53.       Siz  : System.Storage_Elements.Storage_Count;
  54.    end record;
  55.  
  56.    type Header is range 1 .. 503;
  57.    function H (F : Address) return Header;
  58.  
  59.    package Table is new GNAT.Htable.Simple_Htable (
  60.      Header_Num => Header,
  61.      Element    => Status,
  62.      No_Element => Status'(Not_Allocated, 0),
  63.      Key        => Address,
  64.      Hash       => H,
  65.      Equal      => "=");
  66.  
  67.    -------
  68.    -- H --
  69.    -------
  70.  
  71.    function H (F : Address) return Header is
  72.    begin
  73.       return Header (1 +
  74.          (System.Storage_Elements.To_Integer (F)
  75.           mod Integer_Address (Header'Last)));
  76.    end H;
  77.  
  78.    --------------
  79.    -- Allocate --
  80.    --------------
  81.  
  82.    procedure Allocate
  83.      (Pool                     : in out Debug_Pool;
  84.       Storage_Address          : out Address;
  85.       Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
  86.       Alignment                : in System.Storage_Elements.Storage_Count)
  87.    is
  88.       function Malloc
  89.         (Size : System.Storage_Elements.Storage_Count)
  90.       return System.Address;
  91.       pragma Import (C, Malloc, "malloc");
  92.  
  93.    begin
  94.       Storage_Address := Malloc (Size_In_Storage_Elements);
  95.  
  96.       if Storage_Address = Null_Address then
  97.          raise Storage_Error;
  98.       else
  99.          Table.Set (Storage_Address,
  100.            Status'(Allocated, Size_In_Storage_Elements));
  101.       end if;
  102.    end Allocate;
  103.  
  104.    ----------------
  105.    -- Deallocate --
  106.    ----------------
  107.  
  108.    procedure Deallocate
  109.      (Pool                     : in out Debug_Pool;
  110.       Storage_Address          : in Address;
  111.       Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
  112.       Alignment                : in System.Storage_Elements.Storage_Count)
  113.    is
  114.       procedure Free (Address : System.Address; Siz : Storage_Count);
  115.       --  Faked free, that reset all the deallocated storage to
  116.       --  "DEADBEEF"
  117.  
  118.       procedure Free (Address : System.Address; Siz : Storage_Count) is
  119.          DB : constant Storage_Array (0 .. 3)
  120.                 := (16#DE#, 16#AD#, 16#BE#, 16#EF#);
  121.          DB_Index : Storage_Offset := DB'First;
  122.  
  123.          subtype Dead_Memory is Storage_Array (1 .. Siz);
  124.          type Mem_Ptr is access all Dead_Memory;
  125.  
  126.          function From_Ptr is
  127.            new Unchecked_Conversion (System.Address, Mem_Ptr);
  128.  
  129.       begin
  130.          for J in Dead_Memory'Range loop
  131.             From_Ptr (Address) (J) := DB (DB_Index);
  132.             DB_Index := (DB_Index + 1) mod (DB'Last + 1);
  133.          end loop;
  134.       end Free;
  135.  
  136.       S : Status := Table.Get (Storage_Address);
  137.  
  138.    begin
  139.       case S.Stat is
  140.          when  Not_Allocated |
  141.                Deallocated   =>
  142.             raise Freeing_Not_Allocated_Storage;
  143.  
  144.          when Allocated =>
  145.  
  146. --  ??? Bug in Gigi, the size given by Deallocate is not always coherent
  147. --      with the allocated size
  148.  
  149. --            if S.Siz /= Size_In_Storage_Elements then
  150. --               raise Freeing_Not_Allocated_Storage;
  151. --            else
  152.                Free (Storage_Address, Size_In_Storage_Elements);
  153.                Table.Set (Storage_Address, Status'(Deallocated, 0));
  154. --            end if;
  155.       end case;
  156.    end Deallocate;
  157.  
  158.    ------------------
  159.    -- Storage_Size --
  160.    ------------------
  161.  
  162.    function Storage_Size
  163.      (Pool : Debug_Pool)
  164.       return System.Storage_Elements.Storage_Count
  165.    is
  166.    begin
  167.       return System.Storage_Elements.Storage_Count'Last;
  168.    end Storage_Size;
  169.  
  170.    -----------------
  171.    -- Dereference --
  172.    -----------------
  173.  
  174.    procedure Dereference
  175.      (Pool                     : in out Debug_Pool;
  176.       Storage_Address          : in Address;
  177.       Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
  178.       Alignment                : in System.Storage_Elements.Storage_Count)
  179.    is
  180.       S : Status := Table.Get (Storage_Address);
  181.  
  182.    begin
  183.       case S.Stat is
  184.          when  Not_Allocated =>
  185.             raise Accessing_Not_Allocated_Storage;
  186.  
  187.          when Deallocated =>
  188.             raise Accessing_Deallocated_Storage;
  189.  
  190.          when Allocated =>
  191.             if S.Siz /= Size_In_Storage_Elements then
  192.                raise  Accessing_Reallocated_Storage;
  193.             end if;
  194.       end case;
  195.    end Dereference;
  196. end System.Debug_Pools;
  197.